home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / vaxprimops.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  8.4 KB  |  219 lines
  1. (herald vaxprimops
  2.         (env (make-empty-early-binding-locale 'nil) constants))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define-constant call-foreign 
  30.   (primop call-foreign ()
  31.     ((primop.make-closed self)
  32.      '(lambda args (error "DEFINE-FOREIGN cannot be interpreted")))
  33.     ((primop.generate self node)
  34.      (generate-foreign-call node))))
  35.  
  36.  
  37. ;;; The PRIMOP.TYPE values are suggestions, none of them are currently used.
  38.  
  39. ;;; COMPARATORS
  40. ;;;===========================================================================
  41.  
  42. (define-constant eq?
  43.   (primop eq? ()
  44.     ((primop.generate self node)
  45.      (eq?-comparator node))
  46.     ((primop.presimplify self node)
  47.      (presimplify-to-conditional node))
  48.     ((primop.make-closed self)
  49.      (make-closed-conditional self))
  50.     ((primop.conditional? self) t)
  51.     ((primop.conditional-type self node)
  52.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  53.     ((primop.type self node)
  54.      '#[type (proc #f (proc #f boolean) top top)])))
  55.  
  56. ;;; TYPE PREDICATES
  57. ;;;===========================================================================
  58.  
  59. (define-local-syntax (define-type-predicate name variant . rest)
  60.   `(define-constant ,name
  61.      ,(xcase variant
  62.         ((and)
  63.          `(make-and-type-predicate ',name . ,rest))
  64.         ((header)
  65.          `(make-header-type-predicate ',name . ,rest)))))
  66.  
  67. (define-constant make-and-type-predicate 
  68.   (primop make-and-type-predicate (name mask value)
  69.  
  70.     (((primop.simplify self node)
  71.       (simplify-parameterized-primop self node)))
  72.  
  73.     ((primop.test-code self node arg)      
  74.      (let ((reg (get-register 'scratch node '*)))
  75.        (emit vax/bicb3 (machine-num mask) arg reg)
  76.        (emit vax/cmpb  (machine-num value) reg)))
  77.     ((primop.presimplify self node)
  78.      (presimplify-predicate node))
  79.     ((primop.make-closed self)
  80.      (make-closed-predicate self))
  81.     ((primop.type-predicate? self) t)
  82.     ((primop.type self node)
  83.      '#[type (proc #f (proc #f boolean) top)])
  84.     ((primop.predicate-type self node)
  85.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  86.     ((primop.variant-id self) name)))
  87.     
  88.  
  89. (define-constant make-header-type-predicate
  90.   (primop make-header-type-predicate (name header)
  91.  
  92.     (((primop.simplify self node)
  93.       (simplify-parameterized-primop self node)))
  94.  
  95.     ((primop.test-code self node arg)
  96.      (emit vax/cmpb arg (machine-num header)))
  97.     ((primop.presimplify self node)
  98.      (presimplify-predicate node))
  99.     ((primop.make-closed self)
  100.      (make-closed-predicate self))
  101.     ((primop.type-predicate? self) t)
  102.     ((primop.type self node)
  103.      '#[type (proc #f (proc #f boolean) top)])
  104.     ((primop.predicate-type self node)
  105.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  106.     ((primop.variant-id self) name)))
  107.  
  108. (define-type-predicate list?            and #xFC tag/pair)         ; low 2 bits
  109. (define-type-predicate extend?          and #xFC tag/extend)
  110. (define-type-predicate immediate?       and #xFC tag/immediate)
  111. (define-type-predicate bignum-header?   and #x80 header/bignum) ; low 7 bits
  112. (define-type-predicate template-header? and #x80 header/template)
  113. (define-type-predicate vcell-header?    and #x80 header/vcell)  ; 
  114. (define-type-predicate bytev-header?    and #x80 header/bytev)  ; pure bit
  115. (define-type-predicate text-header?     and #x80 header/text)   ; pure bit
  116.  
  117.  
  118. (define-type-predicate char?                  header header/char)
  119. (define-type-predicate nonvalue?              header header/nonvalue)
  120. (define-type-predicate general-vector-header? and #x80 header/general-vector)
  121. (define-type-predicate string-header?         and #x80 header/slice)
  122. (define-type-predicate symbol-header?         and #x80 header/symbol)
  123. (define-type-predicate foreign-header?        and #x80 header/foreign)
  124. (define-type-predicate unit-header?           and #x80 header/unit)
  125. (define-type-predicate true-header?           header header/true)
  126. (define-type-predicate double-float-header?   header header/double-float)
  127. (define-type-predicate vframe-header?         and #x80 header/vframe)
  128.                                                     
  129. (define-type-predicate weak-set-header?   and #x80 header/weak-set)
  130. (define-type-predicate weak-alist-header? and #x80 header/weak-alist)
  131. (define-type-predicate weak-table-header? and #x80 header/weak-table)
  132. (define-type-predicate weak-cell-header?  and #x80 header/weak-cell)
  133.  
  134.  
  135. (define-constant fixnum?
  136.   (primop fixnum? ()
  137.     ((primop.test-code self node arg)
  138.      (emit vax/bitl (machine-num 3) arg))
  139.     ((primop.presimplify self node)
  140.      (presimplify-predicate node))
  141.     ((primop.make-closed self)
  142.      (make-closed-predicate self))
  143.     ((primop.type-predicate? self) t)
  144.     ((primop.type self node)
  145.      '#[type (proc #f (proc #f boolean) top)])
  146.     ((primop.predicate-type self node)
  147.      '#[type (proc #f (proc #f) (proc #f) top top top)])))
  148.  
  149.  
  150. ;;; MAKE-VECTORS
  151. ;;;=========================================================================
  152.  
  153. (define-constant make-vector-extend
  154.   (primop make-vector-extend ()
  155.     ((primop.arg-specs self) '(* 9 1))   ;; AN and S1
  156.     ((primop.generate self node)
  157.      (generate-make-vector-extend node))))
  158.  
  159. (define-constant %make-extend
  160.   (primop %make-extend ()
  161.     ((primop.arg-specs self) '(9 1))   ;; AN and S1
  162.     ((primop.generate self node)
  163.      (generate-make-extend node))
  164.     ((primop.type self node)
  165.      '#[type (proc #f (proc #f top) template fixnum)])))
  166.  
  167.  
  168. ;;; MAKE-PAIR
  169.  
  170. (define-constant %make-pair
  171.   (primop %make-pair ()
  172.     ((primop.generate self node)
  173.      (generate-make-pair node))
  174.     ((primop.type self node)
  175.      '#[type (proc #f (proc #f pair))])))
  176.  
  177. ;;; ONE-ARG-PRIMITIVES
  178. ;;;==========================================================================
  179.  
  180.  
  181. (define-constant descriptor->fixnum
  182.   (primop descriptor->fixnum ()
  183.     ((primop.generate self node)
  184.      (receive (source target rep) (one-arg-primitive node)
  185.        (emit vax/bicl3 (machine-num 3) source target)
  186.        (really-rep-convert node target 'rep/pointer target rep)
  187.        (mark-continuation node target)))
  188.     ((primop.type self node)
  189.      '#[type (proc #f (proc #f fixnum) top)])))
  190.  
  191. (define-constant descriptor-tag
  192.   (primop descriptor-tag ()
  193.     ((primop.generate self node)
  194.      (receive (source target rep) (one-arg-primitive node)
  195.        (emit vax/ashl (machine-num 2) source target)
  196.        (emit vax/bicl2 (machine-num #xFFFFFFF0) target) ; get low 4 bits
  197.        (really-rep-convert node target 'rep/pointer target rep)
  198.        (mark-continuation node target)))
  199.     ((primop.type self node)
  200.      '#[type (proc #f (proc #f fixnum) top)])))
  201.  
  202. (define-constant header-type
  203.   (primop header-type ()
  204.     ((primop.generate self node)
  205.      (receive (source target rep) (one-arg-primitive node)
  206.        (emit vax/bicl3 (machine-num #xFFFFFf83) source target) ; get low 7 bits
  207.        (really-rep-convert node target 'rep/pointer target rep) ; mask out tag
  208.        (mark-continuation node target)))
  209.     ((primop.type self node)
  210.      '#[type (proc #f (proc #f fixnum) top)])))
  211.  
  212. (define-constant %chdr
  213.   (primop %chdr ()
  214.     ((primop.side-effects? self) t)
  215.     ((primop.generate self node)
  216.      (generate-%chdr node))))
  217.  
  218.  
  219.